home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / DATATION / QPARSER.LZH / CALCUTIL.PAS < prev    next >
Pascal/Delphi Source File  |  1985-07-26  |  4KB  |  127 lines
  1.   { CALCUTIL:  Calculator Utilities. }
  2.   { Copyright (C) 1984 by QCAD Systems Inc., All Rights Reserved. }
  3.  
  4.   {******************}
  5.   procedure WRITE_VALUE(R:  real);
  6.     { writes r to the screen in a 'reasonable' format.  must resort
  7.       to Turbo's exponential notation in extreme cases. }
  8.     const
  9.       MIN_MAGNITUDE = -38;
  10.       { Turbo Pascal has roughly 12 decimal digits of precision;
  11.         keep the last one as a guard digit. }
  12.       PRECISION = 11;
  13.     var
  14.       MAGNITUDE:  integer;
  15.       FRACTION:  real;
  16.       FUZZ:  real;  { number to compare against for roundoff }
  17.  
  18.     {..................}
  19.     procedure WRITE_FRACTION(FRACTION: real;  DIGITS: integer);
  20.       { chunk out zero or more digits of the fraction, until either
  21.         the digit count gives out, or we run into the fuzz. }
  22.     begin
  23.       while (abs(fraction) > fuzz) and (digits > 0) do begin
  24.         fraction := fraction * 10.0;
  25.         write(trunc(fraction):1);
  26.         fuzz := fuzz * 10.0;
  27.         digits := digits-1;
  28.         fraction := frac(fraction)
  29.       end
  30.     end;
  31.  
  32.   begin { write_value }
  33.     { first, establish some useful information about R. }
  34.     if r = 0.0 then
  35.       magnitude := 0
  36.     else
  37.       magnitude := trunc(ln(abs(r))/ln(10.0));
  38.     if magnitude-precision >= min_magnitude then begin
  39.       fuzz := exp((magnitude-precision+1)*ln(10.0));
  40.       { Turbo reals tend to err toward zero; use the fuzz to
  41.         compensate for this effect. }
  42.       if r<0.0 then
  43.         r := r-fuzz
  44.       else if r>0.0 then
  45.         r := r+fuzz
  46.       end
  47.     else
  48.       fuzz := 0.0;
  49.     fraction := abs(frac(r));
  50.     { now, decide what to do with R. }
  51.     if (abs(r) >= maxint) or (magnitude < -3) then
  52.       { big enough or small enough for a possible loss of precision:
  53.         use exponential notation. }
  54.       write(r)
  55.     else if fraction < fuzz then
  56.       { essentially whole number of small magnitude }
  57.       write(trunc(r):1)
  58.     else begin
  59.       { real number in ddd.ddd format. }
  60.       if (-1.0 < r) and (r < 0.0) then
  61.         write('-');  { trunc eliminates minus sign for these numbers }
  62.       write(trunc(r):1, '.');
  63.       write_fraction(fraction, precision-magnitude)
  64.     end
  65.   end { write_value };
  66.  
  67.   {******************}
  68.   procedure EVAL_BINOP(OP: operator;  OPND1, OPND2: semrecp;
  69.                        RESULT:  semrecp);
  70.     { evaluate the given binary operator, setting up the result
  71.       semantic record with the resulting value.  if there is an
  72.       error, result will generally contain a non-value (because
  73.       it is set up to be 'other' rather than 'float' by default).
  74.       most of the code here is for error handling. }
  75.     var V1, V2:  real;  { operand values }
  76.         SEM_TYPE:  semtype;  { type of result }
  77.   begin
  78.     if opnd2 = nil then begin
  79.       { actually, its a unary operator }
  80.       if opnd1^.semt = float then begin
  81.         case op of
  82.           uminus:   result^.rval := -opnd1^.rval;
  83.           ELSE error('internal problems in eval_binop')
  84.         end;
  85.         result^.semt := float
  86.       end
  87.     end
  88.     else if opnd1^.semt <> float then
  89.       result^ := opnd2^
  90.     else if opnd2^.semt <> float then
  91.       result^ := opnd1^
  92.     else begin
  93.       { both values are good }
  94.       v1 := opnd1^.rval;
  95.       v2 := opnd2^.rval;
  96.       sem_type := float;
  97.       case op of
  98.         divide:  if v2 <> 0.0 then
  99.                    v1 := v1/v2
  100.                  else begin
  101.                    write('Attempt to divide ');
  102.                    write_value(v1);
  103.                    writeln(' by zero.');
  104.                    sem_type := other
  105.                  end;
  106.         mpy:     v1 := v1*v2;
  107.         plus:    v1 := v1+v2;
  108.         minus:   v1 := v1-v2;
  109.       end;
  110.       result^.semt := sem_type;
  111.       result^.rval := v1
  112.     end
  113.   end;
  114.  
  115.   {******************}
  116.   procedure INIT_SEM;
  117.     { No semantics initialization needed. }
  118.   begin
  119.   end;
  120.  
  121.   {******************}
  122.   procedure END_SEM;
  123.     { No semantics conclusion needed. }
  124.   begin
  125.   end;
  126.  
  127.